
#include <string.h>

#if !defined SIZEOF_DOUBLE || !defined SIZEOF_FLOAT || !defined SIZEOF_LONG \
   				|| !defined SIZEOF_INT || !defined SIZEOF_SHORT

#error Missing/incomplete slirptypes.h: essential type size macros are undefined

#endif

/* Several opaque types are built in, to support passing arrays of    */
/* indeterminate size between S-Lang and C, masked as opaque pointers */
#define NUM_BUILTIN_OPAQUES 11
typedef struct _Builtin_Opaque {
   char	  *name;
   SLtype *type;
   SLtype masked_type;			/* type of datum to which this points */
   SLtype casts[NUM_BUILTIN_OPAQUES];	/* row of cast matrix, which reflects */
} Builtin_Opaque;			/* when/how this type may be cast     */


SLtype 	Opaque_Pointer_Type;
SLtype  String_Pointer_Type;
SLtype 	UChar_Pointer_Type;
SLtype 	Short_Pointer_Type;
SLtype 	UShort_Pointer_Type;
SLtype 	Int_Pointer_Type;
SLtype 	UInt_Pointer_Type;
SLtype 	Long_Pointer_Type;
SLtype 	ULong_Pointer_Type;
SLtype 	Float_Pointer_Type;
SLtype 	Double_Pointer_Type;

#ifndef PROHIBIT_REAL_INT_CONVERSION
#define PROHIBIT_REAL_INT_CONVERSION	0
#endif

#define DEF   (SIZEOF_DOUBLE == SIZEOF_FLOAT)
#define DEL   (SIZEOF_DOUBLE == SIZEOF_LONG  && !PROHIBIT_REAL_INT_CONVERSION)
#define DEI   (SIZEOF_DOUBLE == SIZEOF_INT   && !PROHIBIT_REAL_INT_CONVERSION)
#define DES   (SIZEOF_DOUBLE == SIZEOF_SHORT && !PROHIBIT_REAL_INT_CONVERSION)

#define FEL   (SIZEOF_FLOAT  == SIZEOF_LONG  && !PROHIBIT_REAL_INT_CONVERSION)
#define FEI   (SIZEOF_FLOAT  == SIZEOF_INT   && !PROHIBIT_REAL_INT_CONVERSION)
#define FES   (SIZEOF_FLOAT  == SIZEOF_SHORT && !PROHIBIT_REAL_INT_CONVERSION)

#define LEI   (SIZEOF_LONG   == SIZEOF_INT)
#define LES   (SIZEOF_LONG   == SIZEOF_SHORT)

#define IES   (SIZEOF_INT    == SIZEOF_SHORT)

/* Define how the builtin opaque pointers may be cast.  The policy is that
   casts are permissible to all opaque pointers which point to like-sized
   types.  The exceptions are the Opaque, UChar, and String pointer types,
   which may be cast neither to nor from any other type. */

            /* O  S  D    F    UL   L    UI   I    US   S    UC */

#define DC  {  0, 0, 0,   DEF, DEL, DEL, DEI, DEI, DES, DES, 0   }
#define FC  {  0, 0, DEF, 0,   FEL, FEL, FEI, FEI, FES, FES, 0   }
#define ULC {  0, 0, DEL, FEL, 0,   1,   LEI, LEI, LES, LES, 0   }
#define LC  {  0, 0, DEL, FEL, 1,   0,   LEI, LEI, LES, LES, 0   }
#define UIC {  0, 0, DEI, FEI, LEI, LEI, 0,   1,   IES, IES, 0   }
#define IC  {  0, 0, DEI, FEI, LEI, LEI, 1,   0,   IES, IES, 0   }
#define USC {  0, 0, DES, FES, LES, LES, IES, IES, 0,   1,   0   }
#define SC  {  0, 0, DES, FES, LES, LES, IES, IES, 1,   0,   0   }

static Builtin_Opaque Builtin_Opaque_Types[] = {

   { "Opaque_Pointer", &Opaque_Pointer_Type, SLANG_ANY_TYPE,    {0} },
   { "String_Pointer", &String_Pointer_Type, SLANG_STRING_TYPE, {0} },
   { "Double_Pointer", &Double_Pointer_Type, SLANG_DOUBLE_TYPE, DC  },
   { "Float_Pointer",  &Float_Pointer_Type,  SLANG_FLOAT_TYPE,  FC  },
   { "ULong_Pointer",  &ULong_Pointer_Type,  SLANG_ULONG_TYPE,  ULC },
   { "Long_Pointer",   &Long_Pointer_Type,   SLANG_LONG_TYPE,   LC  },
   { "UInt_Pointer",   &UInt_Pointer_Type,   SLANG_UINT_TYPE,   UIC },
   { "Int_Pointer",    &Int_Pointer_Type,    SLANG_INT_TYPE,    IC  },
   { "UShort_Pointer", &UShort_Pointer_Type, SLANG_USHORT_TYPE, USC },
   { "Short_Pointer",  &Short_Pointer_Type,  SLANG_SHORT_TYPE,  SC  },
   { "UChar_Pointer",  &UChar_Pointer_Type,  SLANG_UCHAR_TYPE,  {0} },
   {NULL}
};

static int
opaque_typecast (unsigned char from_type, VOID_STAR from_p,
      		unsigned int num, unsigned char to_type, VOID_STAR to_p)
{
   unsigned int i;
   SLang_MMT_Type **from = (SLang_MMT_Type**)from_p;
   SLang_MMT_Type **to   = (SLang_MMT_Type**)to_p;

   /* FIXME: typeof() still reports original type */
   for (i=0; i < num; i++) {
	to[i] = from[i];
	if (from[i] != NULL)
	   SLang_inc_mmt(from[i]);
   }

   return 1;
}

static SLtype sltype_to_opaque_ptr_type(SLtype sltype)
{
   Builtin_Opaque *bi = Builtin_Opaque_Types;
   while (bi->name) {
	if (bi->masked_type == sltype)
	   return *bi->type;
	bi++;
   }

   if (sltype - First_Opaque_Type > 0)
	return First_Opaque_Type;		/* best guess */

   return 0;
}

SLtype First_Opaque_Type;

SLang_MMT_Type*
create_opaque_mmt(SLtype type, void *instance, unsigned int owns_ref)
{
   SLang_MMT_Type *mmt = NULL;
   Slirp_Opaque *ot = (Slirp_Opaque*) SLmalloc(sizeof(Slirp_Opaque));
   if (ot != NULL) {
      ot->instance = instance;
      ot->owns_ref = owns_ref;
      ot->type = Slirp_Opaque_Types[type - First_Opaque_Type];
      mmt = SLang_create_mmt (type, (VOID_STAR) ot);
      if (mmt == NULL)
	 SLfree((char*)ot);
   }

   return mmt;
}

int SLang_push_opaque(SLtype type, void *instance, unsigned int owns_ref)
{
   SLang_MMT_Type *mmt;

   if (instance == NULL)
      return SLang_push_null();

   mmt = create_opaque_mmt(type, instance, owns_ref);
   if (NULL == mmt)
      return -1;

   return SLang_push_mmt(mmt);
}

int
SLang_pop_opaque(SLtype sltype,Slirp_Opaque **opaque,SLang_MMT_Type **mmt)
{
   Slirp_Opaque *ot;

   *mmt = NULL;

   if (NULL == (*mmt = SLang_pop_mmt(sltype)))
      goto failure_return;

   if ( (ot = (Slirp_Opaque*) SLang_object_from_mmt (*mmt)) && ot->instance) {
	*opaque = ot;
	return 0;
   }

   failure_return:

   SLang_free_mmt (*mmt);
   return -1;
}

int
pop_opaque_or_null(SLtype id, Slirp_Opaque **opaque, SLang_MMT_Type **mmt)
{
   if (SLANG_NULL_TYPE == SLang_peek_at_stack ()) { 
	*opaque = NULL;
	*mmt    = NULL;
	return SLang_pop_null ();
   }

   return SLang_pop_opaque(id, opaque, mmt);
}

int pop_cstruct_or_null(void **pstruct, SLang_CStruct_Field_Type *layout)
{
   if (SLANG_NULL_TYPE == SLang_peek_at_stack ()) {
	*pstruct = NULL;
	return SLang_pop_null ();
   }
   return SLang_pop_cstruct(*pstruct,layout);
}

int pop_obj_or_null(SLtype type, void **obj)
{
   if (SLANG_NULL_TYPE == SLang_peek_at_stack ()) { 
	*obj = NULL;
	return SLang_pop_null ();
   }

   /* Because MMT types require caller to explicitly free the MMT
      associated with the object being managed, MMT types are not
      handled here */

   switch(type) {

	case SLANG_ANY_TYPE:
	   return SLang_pop_anytype((SLang_Any_Type**)obj);

	case SLANG_REF_TYPE:
	   return SLang_pop_ref((SLang_Ref_Type**)obj);

	case SLANG_STRING_TYPE:
	   return SLang_pop_slstring ((char**)obj);

	default:
	   SLang_verror (SL_NOT_IMPLEMENTED,
		"pop_obj_or_null: does not support %d type",type);
	   return -1;
   }

}

int Slirp_finalize_ref(Slirp_Ref *sref, SLtype sltype)
{
   int status = 0;

   if (sref->ref) {
	status = SLang_assign_to_ref (sref->ref, sltype, sref->data);
	SLang_free_ref(sref->ref);
   }
   else if (sref->array)
	SLang_free_array(sref->array);
   else if (sref->mmt)
	SLang_free_mmt(sref->mmt);

   return status;
}

int pop_string_or_null (char **s)
{   
   return pop_obj_or_null ( SLANG_STRING_TYPE, (void**)s);
}

int pop_ref_or_null(SLang_Ref_Type **r)
{
   return pop_obj_or_null ( SLANG_REF_TYPE, (void**)r);
}

int pop_anytype_or_null(SLang_Any_Type **r)
{
   return pop_obj_or_null (SLANG_ANY_TYPE, (void**)r);
}

int pop_array_or_ref(int type, void *pv, Slirp_Ref *sref)
{
   unsigned int objtype = SLang_peek_at_stack();

   memset(sref,0,sizeof(Slirp_Ref));

   switch(objtype) {

	case SLANG_ARRAY_TYPE:

	   if (SLang_pop_array_of_type(&sref->array,type) == -1)
		return -1;

	   sref->data = sref->array->data;
	   break;

	case SLANG_REF_TYPE:

	   if (SLang_pop_ref(&sref->ref) == -1)
		return -1;

	   sref->data = pv;
	   break;

	case SLANG_CHAR_TYPE:		/* treat scalar instances of basic */
	case SLANG_UCHAR_TYPE:		/* types as 1-elementn arrays      */
	case SLANG_SHORT_TYPE:
	case SLANG_USHORT_TYPE:
	case SLANG_INT_TYPE:
	case SLANG_UINT_TYPE:
	case SLANG_LONG_TYPE:
	case SLANG_ULONG_TYPE:
	case SLANG_FLOAT_TYPE:
	case SLANG_DOUBLE_TYPE:

	{
	   /* Accomodate FORTRAN pass by reference semantics */

	   if (map_scalars_to_refs && 
		 	SLang_pop_array_of_type(&sref->array,type) == 0) {

           	memcpy(pv,sref->array->data,(size_t)sref->array->sizeof_type);
		sref->data = pv;
		break;
	   }
	}
	   /* intentional fallthrough */

	default:

	   {

	   /* Check for opaque ptr which masks C array of indeterminate size */
	   /* Note that an SLtype value >= First_Opaque_Type is a necessary, */
	   /* but not sufficient, condition for identifying an opaque type   */
	   /* on the stack, since other types may have been defined, e.g. in */
	   /* other code or modules, _after_ the SLIRP opaques were defined. */
	   int possible_opaque_type = objtype - First_Opaque_Type;

	   if (possible_opaque_type >= 0) {

		SLtype opaque_ptr = sltype_to_opaque_ptr_type(type);
		if (opaque_ptr) {

		   Slirp_Opaque *otp;
		   if (SLang_pop_opaque(opaque_ptr, &otp, &sref->mmt) == -1)
			return -1;

		   sref->data = otp->instance;
		   return 0;
		}
	   }

	   SLang_verror(SL_INTRINSIC_ERROR,
			"unable to interpret arg as array of correct type");
	   return -1;

	   }
   }

   return 0;
}

static void destroy_opaque(unsigned char type, VOID_STAR w)
{
   Slirp_Opaque *ot = (Slirp_Opaque*)w;

   (void) type;

   if (ot->type->finalizer != NULL)
      (*ot->type->finalizer) (ot->instance);

   SLfree( (char*)w );
}

unsigned int
allocate_opaque(char *name, FINALIZER finalizer, SLtype parent_id)
{
   /* Returning from here with anything but a positive id is fatal */

   Slirp_Type *type , *parent = NULL;
   SLang_Class_Type *class = SLclass_allocate_class (name);
   if (class == NULL) return SLANG_UNDEFINED_TYPE;

   (void) SLclass_set_destroy_function (class, destroy_opaque);
   if (-1 == SLclass_register_class (class, SLANG_VOID_TYPE,
				     sizeof(Slirp_Opaque),
				     SLANG_CLASS_TYPE_MMT))
	return SLANG_UNDEFINED_TYPE;

   if (parent_id) {

	type = parent = Slirp_Opaque_Types[parent_id - First_Opaque_Type];

	while (type) {

	   /* Support downcasting ancestor types to this type */
	   if (-1 == SLclass_add_typecast (type->class->cl_data_type, 
				class->cl_data_type, opaque_typecast, 1))
		return SLANG_UNDEFINED_TYPE;

	   /* Support upcasting this type to each ancestor type */
	   if (-1 == SLclass_add_typecast (class->cl_data_type,
				type->class->cl_data_type, opaque_typecast, 1))
		return SLANG_UNDEFINED_TYPE;

	   type = type->parent;
	}
   }

   if ( (type = (Slirp_Type*) SLmalloc(sizeof(Slirp_Type))) == NULL)
	return SLANG_UNDEFINED_TYPE;

   type->class = class;
   type->parent = parent;
   type->finalizer = finalizer;
   Slirp_Opaque_Types[ Slirp_Num_Opaque_Types++ ] = type;

   return type->class->cl_data_type;
}

int allocate_builtin_opaque_types(void)
{

   Builtin_Opaque *bi;
   int i;

   if (Slirp_Num_Opaque_Types) return 0;

   bi = Builtin_Opaque_Types;

   while (bi->name != NULL) {
	if ((*bi->type = allocate_opaque(bi->name,NULL,0)) == 
	      						SLANG_UNDEFINED_TYPE)
		return -1;
	   bi++;
	}

   /* Loop again, to enable casts to/from selected types */
   bi = Builtin_Opaque_Types;
   while (bi->name != NULL) {
	for (i = 0; i < NUM_BUILTIN_OPAQUES; i++) {
	    if (bi->casts[i]) {

		if (SLclass_add_typecast (*bi->type,
					*Builtin_Opaque_Types[i].type,
					opaque_typecast, 1) == -1)

		   return SLANG_UNDEFINED_TYPE;
	    }
	}
	bi++;
   }

   First_Opaque_Type = *Builtin_Opaque_Types[0].type;

   return 0;
}

void slirp_debug_pause(char *module_name)
{
   const char *var = getenv("SLIRP_DEBUG_PAUSE");
   if (var == NULL)
	return;

 {
   const char *prefix  = "slirp_debug_pause:";
   int pause = atoi(var);

   if (module_name == NULL)
	module_name = "";

   if (pause < 0) {
	pause = abs(pause);
	fprintf(stderr,"\n%s entered, ", prefix);
	fprintf(stderr,"will exit after %d second(s) ...\n",pause);
	sleep(pause);
	return;
   }

   fprintf(stderr,"\n%s %s module symbols have been loaded",prefix,module_name);
   fprintf(stderr,"\n%s set breakpoint(s) in debugger window, then",prefix);
   fprintf(stderr,"\n%s press any key in this window to continue\n",prefix);
   pause = getchar();
 }

}

static void recover_unrecoverable_error_hook(char *error_msg)
{
   fputs(error_msg,stderr);	/* support function, which lets scripts */
   fputs("\r\n", stderr);	/* catch "unrecoverable" errors within  */
   fflush (stderr);		/* an ERROR_BLOCK */
   SLang_restart(0);
   SLang_Error = SL_USAGE_ERROR;

}

static void toggle_error_hook()
{
   static void (*previous_error_hook)(char *);

   if (SLang_Error_Hook == recover_unrecoverable_error_hook)
	SLang_Error_Hook = previous_error_hook;
   else {
	previous_error_hook = SLang_Error_Hook;
	SLang_Error_Hook = recover_unrecoverable_error_hook;
   }
}
unsigned char map_scalars_to_refs = 0;


SLtype GladeXML_Type;
Slirp_Type **Slirp_Opaque_Types;
SLtype Slirp_Num_Opaque_Types;
static SLtype Num_New_Opaques_To_Add = 1;

int allocate_glade_opaque_types(void)
{
   if (!SLang_is_defined("_slirp_initialized")) { 
	Slirp_Opaque_Types = NULL;
	Slirp_Num_Opaque_Types = 0;
	/* ensure builtins are allocated only once,     */
	/* and add 1 extra element to keep slot 0 empty */
	Num_New_Opaques_To_Add += (NUM_BUILTIN_OPAQUES + 1);
	(void)SLang_load_string("public variable _slirp_initialized=1;");
   }
   Slirp_Opaque_Types = (Slirp_Type**) SLrealloc((char*)Slirp_Opaque_Types, 
		(Slirp_Num_Opaque_Types + Num_New_Opaques_To_Add) *
			sizeof(Slirp_Type*));

   if (Slirp_Opaque_Types == NULL) return -1;

   Slirp_Opaque_Types[0] = NULL;
   allocate_builtin_opaque_types();

   GladeXML_Type = allocate_opaque("GladeXML",
		NULL,
		(SLtype) GObject_Type);
   if (GladeXML_Type == SLANG_UNDEFINED_TYPE) return -1;

   return 0;
}
